perm filename CLFZ.F4[MSS,LCS]2 blob
sn#086983 filedate 1974-03-19 generic text, type T, neo UTF8
00010 C**** CLEFS, JDRAW, CENTR, LINX *********
00100 SUBROUTINE CLEFS
00200 IMPLICIT INTEGER(A-Q,S-Z)
00300 DIMENSION JCLEF(10),MCLEF(400),RCMIN(4)
00400 REAL DIS,PWDS,DISX,CENTR,POS,STF
00500 COMMON /STF/RSTFAC(8),RSTJC
00600 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00700 COMMON/PLTR/PLT,RHT,DIS
00800 DATA RCMIN/3.3,10.5,7.0,10.5/,JFX/-1/
00900 EQUIVALENCE (JD,JQ(2)),(RJD,RJQ(2)),(JE,JQ(3))
01000 1 ,(RJF,RJQ(4)),(RJE,RJQ(3)),(JH,JQ(6)),(RJG,RJQ(5))
01100 NM='CLFX'
01200 JE=MOD(JE,100)
01300 IF(JE.EQ.0)JE=1
01400 IF(JA.EQ.3)GO TO 2
01500 NM='DRAW1'
01600 IF(JE.GE.10)NM='DRAW2'
01700 C 9 X 2 OBJECTS AVAILABLE. ALSO 50 WDS LEFT IN CLFX
01800 2 JEZ=MOD(JE,10)
01900 IF(NM.EQ.JNM)GO TO 30
02000 C JUMP IF ALREADY IN CORE
02100 JNM=NM
02200 CALL RDDATA(NM,JCLEF,MCLEF)
02300 CC30 CENTR=POS+2*RSTJC+RJD*RSTJC*7
02400 30 CALL CENTER(CENTR)
02500 C CHECK THE ABOVE -- FOR P5 HEIGHT CHANGE *********************
02600 IF(RJF.EQ.0)RJF=1
02700 IF(RJG.EQ.0)RJG=1
02800 C RJF IS SIZE FACTOR
02900 IF(JE.GT.4.OR.JA.NE.3)GO TO 811
03000 IF(RJE.LT.100)GO TO 812
03100 RSTJC=.8*RSTJC
03200 CENTR=CENTR+RCMIN(JEZ)*RSTJC
03300 C TO SET HGT. OF MINI CLEFS
03400 812 IF(JEZ.NE.4)GO TO 811
03500 CENTR=CENTR+RSTJC*14
03600 JEZ=3
03700 C ABOVE IS NOW AT TOP
03800 811 L=JCLEF(JEZ)
03900 CALL JDRAW(MCLEF(L),RJB,CENTR,RSTJC,RJF,RJG)
04000 C 3,POS.,STF,NT# OR CLEF,ITEM#,SIZEX,SIZEY, JH=-1 TO FILL ON CRT
04100 C JH=-2 OMITS FILLER DURING PLOT
04200
04300 N=0
04400 JD=MCLEF(L)+L
04500 IF(MCLEF(JD).EQ.999)N=JD+1
04600 1 IF(N.NE.0.AND.JH.NE.-2.AND.(PLT.OR.JH))CALL FILLER(MCLEF(N),
04700 1 RJB,CENTR,RJF,RJG)
04800 C FILLS ONLY WHEN PLOTING OR RJG=-1
04900 END
05000
05100 SUBROUTINE JDRAW(M,RJB,CENTR,RSTJC,RX,RY)
05200 COMMON/LL/LL
05300 DIMENSION M(1)
05400 RC=RX*RSTJC
05500 RD=RY*RSTJC
05600 DO 2 K=2,M(1)
05700 CALL UNPACK(IA,IB,M(K))
05800 CC RA=IA*RC+RJB
05900 CC RB=IB*RD+CENTR
06000 CC IF(K.EQ.I)LL=3
06100 CC2 CALL LINES(RA,RB,LL)
06200 2 CALL LINES(FLOAT(IA)*RC+RJB,FLOAT(IB)*RD+CENTR,LL)
06300 END
06400
06500 SUBROUTINE CENTER(CNTR)
06600 C TO CENTER ITEMS CREATED WITH DRAWING PROG.
06700 COMMON /STF/RSTFAC(8),RSTJC
06800 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
06900 COMMON/POSI/STF(8),JJB,POS
07000 EQUIVALENCE (RJD,RJQ(2))
07100 CNTR=POS+2+AMOD(RJD,100.)*RSTJC*7
07200 END
07300
30000 SUBROUTINE LINX(A,B,C,D)
30100 C SAVES SPACE FOR SINGLE LINES.
30200 CALL LINES(A,B,3)
30300 CALL LINES(C,D,2)
30400 END